perm filename STRING[NEW,LSP] blob
sn#548016 filedate 1980-11-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00026 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 STRING -*-MODE:LISPPACKAGE:SI-*- -*-LISP-*-
C00010 00003 Out-of-core loading, and DECLAREs
C00013 00004 #-FOR-NIL Need CLASS-OF, SEND etc, for things to work
C00016 00005 #+PDP10
C00018 00006 Temporary macros
C00020 00007 #+PDP10 (progn 'compile
C00023 00008 Initial setups
C00026 00009 Bothmacros and lexprmacros
C00030 00010 In real NIL, defmumble generates a DEFUN which "passes along" a call
C00034 00011 #-PDP10 These come in from the STRAUX file for maclisp
C00036 00012 Maclisp MAKE-STRING, and gc support
C00040 00013 Remember, still within a #+FM conditional
C00043 00014 Still within a #+PDP10
C00047 00015 *:FIXNUM-TO-CHARACTER, DIGITP, DIGITP-N
C00051 00016 STRING-PNGET and STRING-PNPUT
C00054 00017 Still within an #+FM
C00057 00018 DIGITP, DIGIT-WEIGHT, and |STR/:STRING-SEARCHer|
C00061 00019 SUBSTRING, STRING-APPEND, STRING-REVERSE, STRING-NREVERSE,
C00064 00020 STR/:STRING-REVERSER STR/:STRING-EQUAL-LESSP
C00069 00021 Remember, still within a #-LISPM conditional
C00072 00022 Fill-in primitives
C00075 00023 PDP10 hooks - Methods for PRINT, EXPLODE, SXHASH, NAMESTRING
C00079 00024 PDP10 hooks - methods for EQUAL, FLATSIZE, PURCOPY, USERATOMS
C00082 00025 Set up tables and constants
C00085 00026 (mapc '(lambda (x) (putprop x #T '|side-effectsp/||))
C00088 ENDMK
C⊗;
;;; STRING -*-MODE:LISP;PACKAGE:SI-*- -*-LISP-*-
;;; **************************************************************
;;; *** NIL ***** Functions for CHARACTERs and STRINGs ***********
;;; **************************************************************
;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;;; Provides support for NIL string operations under maclisp, with
;;; most LISPM STRING functions added for compatibility.
;;; To read this file in on LISPM, do (PACKAGE-DECLARE * SYSTEM 100)
(herald STRING /124)
;;; CHARACTER support:
;;; m CHARACTERP, *:CHARACTER-TO-FIXNUM, *:FIXNUM-TO-CHARACTER
;;; m TO-CHARACTER, TO-CHARACTER-N,
;;; DIGITP, DIGIT-WEIGHT
;;; +m CHARACTER,
;;; +* CHAR-EQUAL, CHAR-LESSP,
;;; & |+internal-tilde-macro/|| (can be set onto } as readmacro)
;;; & USERATOMS-HOOK->CHARACTER-CLASS FLATSIZE->CHARACTER-CLASS
;;; STRING support:
;;; m STRINGP, CHAR, RPLACHAR
;;; m STRING-LENGTH, SET-STRING-LENGTH, STRING-SEARCHQ, STRING-BSEARCHQ
;;; MAKE-STRING, STRING-SUBSEQ, STRING-MISMATCHQ, STRING-HASH
;;; * CHAR-N, RPLACHAR-N, STRING-FILL, STRING-FILL-N, STRING-REPLACE
;;; * STRING-POSQ, STRING-BPOSQ, STRING-POSQ-N, STRING-BPOSQ-N
;;; * STRING-SKIPQ, STRING-BSKIPQ, STRING-SKIPQ-N, STRING-BSKIPQ-N
;;; +m STRING-EQUAL, STRING-LESSP, STRING-SEARCH, STRING-REVERSE-SEARCH
;;; +m STRING-DOWNCASE, STRING-UPCASE
;;; + GET-PNAME, SUBSTRING, STRING-APPEND, STRING-REVERSE, STRING-NREVERSE
;;; + STRING-TRIM, STRING-LEFT-TRIM, STRING-RIGHT-TRIM
;;; +* CHAR-DOWNCASE, CHAR-UPCASE,
;;; +* STRING-SEARCH-CHAR, STRING-SEARCH-NOT-CHAR,
;;; +* STRING-SEARCH-SET, STRING-SEARCH-NOT-SET
;;; +* STRING-REVERSE-SEARCH-CHAR, STRING-REVERSE-SEARCH-NOT-CHAR,
;;; +* STRING-REVERSE-SEARCH-SET, STRING-REVERSE-SEARCH-NOT-SET
;;; & STRING-PNGET, STRING-PNPUT, |+internal-doublequote-macro/||
;;; & USERATOMS-HOOK->STRING-CLASS EQUAL->STRING-CLASS
;;; & FLATSIZE->STRING-CLASS PURCOPY->STRING-CLASS
;;; & NAMESTRING->STRING-CLASS SXHASH->STRING-CLASS
;;; & EXPLODE->STRING-CLASS ALPHALESSP->STRING-CLASS
;;; & SAMEPNAMEP->STRING-CLASS
;;; &* STR/:CLEAR-WORDS, STR/:GRAB-PURSEG,
;;; &* +INTERNAL-CHAR-N, +INTERNAL-RPLACHAR-N, +INTERNAL-STRING-WORD-N
;;; (a "m" is for lines whose routines are implemnted as both macros and
;;; subrs - macro definition is active only in the compiler)
;;; (a + is for lines whose routines are directly LISPM compatible -
;;; many other such routines can be written using the NIL primitives)
;;; (an * is for lines whose routines have been written in MIDAS -
;;; primarily for speed - and are in the file STRAUX >)
;;; (a & is for lines whose routines are PDP10-specific, and are
;;; primarily for internal support)
;;; (the functions named "...-N" use ascii numerical values for their
;;; arguments which are interpreted as "CHARACTER"s, instead of the
;;; new datatype "CHARACTER" - thus while STRING-POSQ scans for a
;;; particular character in a string, STRING-POSQ-N wants its character
;;; as a fixnum.)
;;;; Out-of-core loading, and DECLAREs
#M
(eval-when (eval compile)
(cond ((status feature FOR-NIL))
(T (sstatus feature FOR-MACLISP)
(sstatus feature FM)))
)
(defmacro (lispdir defmacro-for-compiling () defmacro-displace-call () ) (x)
#+Pdp10 `(quote ((lisp) ,x))
#+Lispm (string-append "lisp;" (get-pname x) "qfasl")
#+Multics (catenate ">exl>lisp←dir>object" (get←pname x))
#+For-NIL (string-append "lisp:" (get-pname x) "vasl")
)
(defmacro (subload defmacro-for-compiling () defmacro-displace-call () ) (x)
`(OR (GET ',X 'VERSION) (LOAD (LISPDIR ,X))))
#M (declare (own-symbol MAKE-STRING STRINGP *:FIXNUM-TO-CHARACTER
|+internal-doublequote-macro/|| STRING-PNPUT))
#-FOR-NIL
(eval-when (eval compile)
;; SUBSEQ also downloads EXTEND
(subload SUBSEQ)
(subload UMLMAC)
(subload EXTMAC)
(subload SETF)
(subload EVONCE)
#M (cond ((status feature COMPLR)
(notype (MAKE-STRING FIXNUM))
(*lexpr NIL-INTERN SYMBOLCONC TO-STRING)
(*expr MAKE-STRING STRINGP *:FIXNUM-TO-CHARACTER )
#+PDP10 (*expr STRING-PNGET STRING-PNPUT)
#+PDP10 (setq STRT7 'T)))
(setq-if-unbound *:bits-per-character #Q 8 #-Lispm 7)
(setq-if-unbound *:bytes-per-word #+Multics 4 #M 5 #Q 4)
)
#-FOR-NIL
(eval-when (eval load compile)
(subload EXTEND)
(or (get 'SUBSEQ 'VERSION)
(get 'SUBSEQ 'AUTOLOAD)
(mapc '(lambda (x) (putprop x (lispdir SUBSEQ) 'AUTOLOAD))
'(TO-CHARACTER TO-CHARACTER-N? TO-STRING TO-UPCASE
SUBSEQ REPLACE SI/:REPLACER )))
)
#-FOR-NIL ;Need CLASS-OF, SEND etc, for things to work
(eval-when (eval load compile)
(cond (#M (status feature COMPLR) #Q 'T
(special CHARACTER-CLASS
|+internal-CHARACTER-table/||
STRING-CLASS
STR/:NULL-STRING)
#M (progn (fixnum (STRING-LENGTH)
(CHAR-N () fixnum)
(CHAR-DOWNCASE fixnum)
(CHAR-UPCASE fixnum))
(notype (RPLACHAR-N () fixnum fixnum))
#+PDP10 (fixnum (+INTERNAL-CHAR-N () fixnum)
(+INTERNAL-STRING-WORD-N () fixnum))
#+PDP10 (notype (+INTERNAL-RPLACHAR-N () fixnum fixnum)
(+INTERNAL-SET-STRING-WORD-N () fixnum fixnum))
(*lexpr
STRING-SKIPQ STRING-BSKIPQ STRING-SKIPQ-N
STRING-BSKIPQ-N STRING-POSQ STRING-BPOSQ
STRING-POSQ-N STRING-BPOSQ-N STRING-FILL
STRING-FILL-N STRING-SEARCH-SET
STRING-REVERSE-SEARCH-SET STRING-SEARCH-NOT-SET
STRING-REVERSE-SEARCH-NOT-SET STRING-SEARCH-CHAR
STRING-REVERSE-SEARCH-CHAR STRING-SEARCH-NOT-CHAR
STRING-REVERSE-SEARCH-NOT-CHAR STRING-REPLACE
STRING-SUBSEQ STRING-MISMATCHQ
SUBSTRING STRING-APPEND )
(array* (FIXNUM (STR/:ARRAY ())))
#+PDP10 (fixnum STR/:GRAB-PURSEG))
))
)
#-LISPM
(eval-when (eval load compile)
(cond (#M (status feature COMPLR) #Q 'T
(special |STR/:STRING-SEARCHer|
|STR/:STRING-POSQ-Ner|
|STR/:STRING-POSQer|
STR/:STRING-EQUAL-LESSP
STR/:STRING-UP-DOWN-CASE)
#+FM (*lexpr |STR/:STRING-SEARCHer|
STR/:STRING-EQUAL-LESSP
STR/:STRING-UP-DOWN-CASE)
#-Multics (*expr GET-PNAME)
))
)
#+PDP10
(declare
(ARRAY* (NOTYPE (STR/:GCMARRAY)))
(*EXPR STR/:GC-DAEMON)
(SPECIAL STRINGS-GCSIZE STRINGS-GCMAX STRINGS-GCMIN)
(SPECIAL
STR/:ARRAY ;fixnum array, holding packed ascii for strings
STR/:ARYSIZE ;current size of above array, in words
STR/:FREESLOT ;slot in array above which no strings stored
STR/:NO/.WDSF ;# wds free, but interspersed between strings
STR/:GCMARRAY ;non-GC-marked s-exp array - holds all strings
STR/:GCMSIZE ;current size of above array, in "entries"
STR/:NO/.STRS ;number of strings currently entered in arrays
STR/:DUMMY ;dummy header used during string relocations
)
(SPECIAL STR/:PURE-ADDR
STR/:NO/.PWDSF
STR/:STRING-HUNK-PATTERN
STR/:CHARACTER-HUNK-PATTERN
STR/:CHARACTER-EXTEND-PATTERN )
)
;;;; Temporary macros
#-FOR-NIL (progn 'compile
(DEFCLASS* STRING STRING-CLASS SEQUENCE-CLASS)
(DEFCLASS* CHARACTER CHARACTER-CLASS OBJECT-CLASS)
)
(defmacro EXCH (x y) `(SETQ ,x (PROG1 ,y (SETQ ,y ,x))))
;; For getting and setting stack args
(defmacro S-ARG (w i)
#+FOR-NIL `(VREF ,w ,i)
#+FM `(ARG (1+ ,i))
#Q `(NTH ,i ,w)
)
(defmacro S-SETARG (w i val)
#+FOR-NIL `(VSET ,w ,i ,val)
#+FM `(SETARG (1+ ,i) ,val)
#Q `(RPLACA (NTHCDR ,i ,w) ,val)
)
#+FM (progn 'compile
(defmacro AR-1 (&rest w) `(ARRAYCALL T ,. w))
(defmacro /" (x)
(unless (symbolp x) (error '|Uluz - /" pseudo-string maker|))
(let ((z (copysymbol x () )))
(setq z z)
(putprop z `(SPECIAL ,z) 'SPECIAL)
(putprop z 'T '+INTERNAL-STRING-MARKER)
z))
#+PDP10 (progn 'compile
(defmacro NEW-CHARACTER (i &optional purep)
`(LET ((I ,i)
(C (COND (,purep (PURCOPY STR/:CHARACTER-HUNK-PATTERN))
('T (SUBST () () STR/:CHARACTER-HUNK-PATTERN)))))
(SETF (*:EXTEND-CLASS-OF C)
(*:EXTEND-CLASS-OF STR/:CHARACTER-EXTEND-PATTERN))
(SETF (*:EXTEND-MARKER-OF C)
(*:EXTEND-MARKER-OF STR/:CHARACTER-EXTEND-PATTERN))
(*:XSET C 0 (MUNKAM I))))
(defmacro NEW-STRING (wordno len)
`(*:EXTEND STRING-CLASS ,wordno ,len))
(defmacro WORD-NO (str) `(*:XREF ,str 0))
;; Warning! Discontinuity at 0: (// -1 5) => -1, instead of 0
(defmacro NO-WORDS-USED (x &aux str-len body)
(setq str-len (cond ((|no-funp/|| x) x)
((gensym)))
body `(COND ((> ,str-len 0) (1+ (// (1- ,str-len) 5)))
('T 1)))
(cond ((eq str-len x) body)
(`(LET ((,str-len ,x)) (DECLARE (FIXNUM ,str-len)) ,body))))
(defmacro SET-WORD-NO (str n) `(*:XSET ,str 0 ,n))
(defsimplemac WORDNO-OF-NEXT-FREESLOT (str)
`(+ (WORD-NO (STR/:GCMARRAY ,str))
(NO-WORDS-USED (STRING-LENGTH ,str))))
)
#-PDP10 (progn 'compile
(defmacro NEW-CHARACTER (i) `(*:EXTEND CHARACTER-CLASS ,i))
(defmacro +INTERNAL-CHAR-N (&rest w) `(CHAR-N ,.w))
(defmacro +INTERNAL-RPLACHAR-N (&rest w) `(RPLACHAR-N ,.w))
)
) ;end of #+FM
(eval-when (compile)
(setq defmacro-for-compiling 'T defmacro-displace-call 'T)
)
;;;; Initial setups
#+PDP10
(cond ((and (get 'STRAUX 'VERSION)
(get 'STR/:ARRAY 'ARRAY)
(eq (car (arraydims 'STR/:ARRAY)) 'FIXNUM)
(get 'STR/:GCMARRAY 'ARRAY)
(null (car (arraydims 'STR/:GCMARRAY)))))
('T (mapc '(lambda (x y) (and (not (boundp x)) (set x y)))
'(STRINGS-GCSIZE STRINGS-GCMAX STRINGS-GCMIN)
'(2048. 20480. .2))
(setq STR/:ARYSIZE STRINGS-GCSIZE
STR/:GCMSIZE 256.
STR/:FREESLOT 0
STR/:NO/.STRS 0
STR/:NO/.WDSF 0
STR/:NO/.PWDSF 0
STR/:PURE-ADDR -1 )
(setq STR/:STRING-HUNK-PATTERN (new-string -1 0))
(setf (*:extend-marker-of STR/:STRING-HUNK-PATTERN) () )
(setf (*:extend-class-of STR/:STRING-HUNK-PATTERN) () )
(setq STR/:CHARACTER-EXTEND-PATTERN
(*:EXTEND CHARACTER-CLASS (MUNKAM #O777777))
STR/:CHARACTER-HUNK-PATTERN
(*:EXTEND CHARACTER-CLASS (MUNKAM #O777777)))
(setf (*:extend-marker-of STR/:CHARACTER-HUNK-PATTERN) () )
(setf (*:extend-class-of STR/:CHARACTER-HUNK-PATTERN) () )
(array STR/:ARRAY FIXNUM STR/:ARYSIZE)
(array STR/:GCMARRAY NIL STR/:GCMSIZE)
;; (setq STR/:NULL-STRING (make-string 0))
((lambda (x y)
(STORE (STR/:GCMARRAY 0) y)
(setq STR/:FREESLOT 1
STR/:NO/.STRS 1
STR/:NULL-STRING y)
(setq STR/:DUMMY (new-string 0 0))
(nointerrupt x))
(nointerrupt 'T)
(new-string 0 0))
(cond ((getddtsym 'grbpsg))
((status feature ITS)
(cond ((eq (status lispv) '/1914)
(defprop GRBPSG 19042. SYM))
((valret '|:symlod/
:vp |))))
;; On non-ITS systems, make the PURE←STRING loader bomb
;; out by doing a THROW
('T (putprop 'GRBPSG (1- (getddtsym 'ERUNDO)) 'SYM)))
(subload STRAUX)))
;;;; Bothmacros and lexprmacros
#-For-NIL (progn 'COMPILE
(defbothmacro CHARACTERP (x) `(EQ (PTR-TYPEP ,x) 'CHARACTER))
#+FM (defbothmacro STRINGP (x) `(EQ (PTR-TYPEP ,x) 'STRING))
#+Multics (defbothmacro STRING-LENGTH (x) `(STRINGLENGTH ,x))
#+Multics (defmacro STRING-APPEND (&rest w) `(CATENATE ,.w))
(defcomplrmac CHAR (str i)
`(*:FIXNUM-TO-CHARACTER (+INTERNAL-CHAR-N ,str ,i)))
(defun CHAR (str i)
(when *RSET (check-subsequence (str i () ) 'STRING 'CHAR))
(char str i))
(defcomplrmac RPLACHAR (str i c)
`(+INTERNAL-RPLACHAR-N ,str ,i (*:CHARACTER-TO-FIXNUM ,c)))
(defun RPLACHAR (str i c)
(when *RSET
(check-subsequence (str i () ) 'STRING 'RPLACHAR)
(check-type c #'CHARACTERP 'RPLACHAR))
(rplachar str i c))
)
(defbothmacro CHARACTER (c) `(TO-CHARACTER-N? ,c () ))
#+FM
(progn 'compile
(defbothmacro *:CHARACTER-TO-FIXNUM (c) `(MAKNUM (*:XREF ,c 0)))
(defbothmacro STRING-LENGTH (x) `(*:XREF ,x 1))
(defbothmacro SET-STRING-LENGTH (x n) `(*:XSET ,x 1 ,n))
) ;end of #+FM
#+(or LISPM MULTICS)
(progn 'compile
(defbothmacro *:CHARACTER-TO-FIXNUM (VAL) `(AR-1 ,val 1))
(defbothmacro CHAR-N (H N) `(AR-1 ,h ,n))
(defbothmacro RPLACHAR-N (H N VAL)
(COND ((OR (|side-effectsp/|| H)
(|side-effectsp/|| N)
(|side-effectsp/|| VAL))
(LET ((HTEM (GENSYM)) (TMP (GENSYM)))
`((LAMBDA (,htem ,tmp) (AS-1 ,val ,htem ,tmp))
,h ,n)))
(`(AS-1 ,val ,h ,n))))
(defbothmacro SET-STRING-LENGTH (x n) `(ADJUST-ARRAY-SIZE ,x ,n))
) ;end of #+(or LISPM MULTICS)
#+FM
(progn 'compile
(defmacro (DEFLEXPRMACRO defmacro-for-compiling () defmacro-displace-call () )
(name fun first-arg args-prop &aux (g (gensym)))
`(PROGN 'COMPILE
(AND (STATUS FEATURE COMPLR)
(EVAL '(DEFMACRO ,name (&REST W)
`(,',fun ,',first-arg ,. W))))
(DEFUN ,name ,g
(DECLARE (FIXNUM ,g))
,g
(|*lexpr-funcall-1| ',name ,fun ,first-arg ,args-prop))))
(defmacro (lexpr-fcl-helper defmacro-for-compiling () defmacro-displace-call () )
(n)
(do ((i 1 (1+ i)) (w () ))
((> i n) `(LSUBRCALL T FUN FIRST-ARG ,. (nreverse w)))
(push `(ARG ,i) w)))
) ;end of #+FM
#-FM
(defmacro DEFLEXPRMACRO (name fun first-arg args-prop &aux (g (gensym)))
`(DEFUN ,name (&REST ,g)
(LEXPR-FUNCALL ,fun ,first-arg ,g)))
;;; In real NIL, defmumble generates a DEFUN which "passes along" a call
;;; to a specific sequence function, as a mini-subr call either with or
;;; without the optional "CNT" argument, depending on whether it was
;;; provided by the source code caller. This strategy allows defaulting
;;; any other optional argument to 0, but permits the mini-subr to
;;; calculate the default for the "count" argument.
#+FOR-NIL
(defmacro defmumble
(name () () args
&aux (cntp (gensym))
(opt-args (list (gensym)))
(req-args (mapcar 'gensym (make-list (car args))))
req-args )
(do ((i (1- (cdr args)) (1- i))
(opt-argsl `(,(car opt-args) 0 ,cntp)))
((<= i (car args))
`(DEFUN ,name (,@req-args &OPTIONAL ,@opt-argsl)
(COND (,cntp (,name ,@req-args ,opt-args))
('T (,name ,@req-args
,(nreverse (cdr (reverse opt-args))))))))
(push (gensym) opt-args)
(push `(,(car opt-args) 0) opt-argsl)))
#-FOR-NIL
(defmacro (defmumble defmacro-for-compiling () defmacro-displace-call () )
(&rest w)
`(DEFLEXPRMACRO ,.w))
;; STRING-SEARCHQ is already mini-subr'd in real NIL
#-FOR-NIL
(defmumble STRING-SEARCHQ |STR/:STRING-SEARCHer| '(SEARCHQ . T) '(2 . 4))
(defmumble STRING-BSEARCHQ |STR/:STRING-SEARCHer| '(SEARCHQ . () ) '(2 . 4))
#-LISPM (progn 'compile
;;; STRING-EQUAL and STRING-LESSP should be rewritten in machine lang?
(deflexprmacro STRING-LESSP STR/:STRING-EQUAL-LESSP '(() . () ) '(2 . 6))
#-FOR-NIL
(deflexprmacro STRING-EQUAL STR/:STRING-EQUAL-LESSP '(() . T) '(2 . 6))
(deflexprmacro STRING-SEARCH |STR/:STRING-SEARCHer| '(SEARCH . T) '(2 . 4))
(deflexprmacro STRING-REVERSE-SEARCH |STR/:STRING-SEARCHer|
'(SEARCH . () ) '(2 . 4))
(deflexprmacro STRING-DOWNCASE STR/:STRING-UP-DOWN-CASE () '(1 . 3))
(deflexprmacro STRING-UPCASE STR/:STRING-UP-DOWN-CASE #T '(1 . 3))
) ;end of #-LISPM
#-PDP10 ;These come in from the STRAUX file for maclisp
(progn 'compile
#-FOR-NIL
(defmumble STRING-POSQ |STR/:STRING-POSQer| '(POSQ . T) '(2 . 4))
(defmumble STRING-BPOSQ |STR/:STRING-POSQer| '(POSQ . () ) '(2 . 4))
#-FOR-NIL
(defmumble STRING-SKIPQ |STR/:STRING-POSQer| '(SKIPQ . T) '(2 . 4))
(defmumble STRING-BSKIPQ |STR/:STRING-POSQer| '(SKIPQ . () ) '(2 . 4))
#-FOR-NIL
(defmumble STRING-POSQ-N |STR/:STRING-POSQ-Ner| '(POSQ . T) '(2 . 4))
(defmumble STRING-BPOSQ-N |STR/:STRING-POSQ-Ner| '(POSQ . () ) '(2 . 4))
#-FOR-NIL
(defmumble STRING-SKIPQ-N |STR/:STRING-POSQ-Ner| '(SKIPQ . T) '(2 . 4))
(defmumble STRING-BSKIPQ-N |STR/:STRING-POSQ-Ner| '(SKIPQ . () ) '(2 . 4))
#-FOR-NIL
(defmumble STRING-FILL |STR/:STRING-POSQer| '(FILL . () ) '(2 . 4))
#-FOR-NIL
(defmumble STRING-FILL-N |STR/:STRING-POSQ-Ner| '(FILL . () ) '(2 . 4))
) ;end of #-PDP10
;;;; Maclisp MAKE-STRING, and gc support
#+PDP10
(progn 'compile
(defun MAKE-STRING (n)
(declare (fixnum n wds-required))
(prog (wds-required str oni cfl gfl *RSET)
(setq oni (nointerrupt 'T) wds-required (no-words-used n))
A (cond ((> (+ wds-required STR/:FREESLOT) STR/:ARYSIZE)
;Do we need GC or COMPRESSION attention?
(cond ((and (null cfl) (< wds-required STR/:NO/.WDSF))
(STR/:COMPRESS-SPACE)
(setq cfl 'T)
(go A)))
(cond ((< (+ wds-required STR/:FREESLOT) STRINGS-GCSIZE)
(str/:grow-array wds-required))
((null gfl)
(str/:gc-service wds-required)
(setq gfl 'T cfl () )
(go A))
('T (error (/" |Can't get enough STRING space|)
wds-required
'FAIL-ACT)
(setq gfl () cfl () )
(go A)))))
;; Here is the basic consification of strings!
(setq str (new-string STR/:FREESLOT n))
(setq STR/:FREESLOT (+ STR/:FREESLOT wds-required)
STR/:NO/.STRS (1+ STR/:NO/.STRS))
(cond ((> STR/:NO/.STRS STR/:GCMSIZE )
(*rearray 'STR/:GCMARRAY
()
(setq n (+ STR/:GCMSIZE 512.)))
(setq STR/:GCMSIZE n)))
(store (STR/:GCMARRAY (1- STR/:NO/.STRS)) str)
(str/:clear-words str wds-required)
(nointerrupt oni)
(return str)))
(defun STR/:GROW-ARRAY (wds-required)
(when (< STR/:NO/.WDSF wds-required)
(setq wds-required
(+ wds-required
(- STR/:FREESLOT STR/:NO/.WDSF)))
(setq wds-required
(+ wds-required
(typecaseq STRINGS-GCMIN
(FLONUM (ifix (*$ STRINGS-GCMIN (float wds-required))))
(FIXNUM STRINGS-GCMIN)
(T 1024.))))
(*rearray 'STR/:ARRAY 'FIXNUM wds-required)
(setq STR/:ARYSIZE wds-required)
(setq STRINGS-GCSIZE (max STRINGS-GCSIZE STR/:ARYSIZE))
(when ↑D (terpri msgfiles)
(princ '|;STRING space grown -- now | msgfiles)
(prin1 STR/:ARYSIZE msgfiles)
(princ '| words.| msgfiles))))
;;; Remember, still within a #+FM conditional
(defun STR/:COMPRESS-SPACE ()
;; *RSET is () when MAKE-STRING calls this function, but most
;; importantly, (NOINTERRUPT 'T) has been done, so there can't be
;; any re-entrant calls!!!
(declare (fixnum i lui nn str-ln current-loc old-loc))
(when ↑D (terpri msgfiles) (princ '|;Compressing STRING space.| msgfiles))
(do ((i 0 (1+ i))
(lui 0) ;last used index
(nn 0) (str-ln 0) (current-loc 0) (old-loc 0)
(str)
(str-free STR/:DUMMY))
((>= i STR/:NO/.STRS) ;Loop thru the GCMARRAY
(setq STR/:NO/.STRS lui ; # strs still alive
STR/:FREESLOT nn ; lowest free index
STR/:NO/.WDSF 0) ; no "interspersed" free space
() )
(setq str (STR/:GCMARRAY i))
(cond (str ;Aha! STRING is alive!
(if (or (null (car str))
(< (setq str-ln (string-length str)) 0)
(> str-ln 1←12.)
(< (setq current-loc (word-no str)) 0))
(error (/" |STRING bug detected by STR/:COMPRESS-SPACE|)
`(STRING ,str)))
(cond ((> (- current-loc old-loc) 0) ;Close gap, if any
(set-string-length str-free str-ln) ; string to the
(set-word-no str-free nn) ; lower slot
(unless (= str-ln 0)
(string-replace str-free str))
(set-word-no str nn)))
;; Update running counters for FREE-SLOTLOC and NO.STRS
(setq nn (+ nn (no-words-used str-ln)))
(setq lui (1+ lui))
(setq old-loc nn)))))
;;; Still within a #+PDP10
(defun STR/:GC-SERVICE (wds-required)
(declare (fixnum wds-required))
(nointerrupt () ) ;Permit GC interrupts, if necessary
(setq STR/:NO/.WDSF -1)
(gc) ;Must run GC-DAEMON to mark STR/:GCMARRAY
(if (< STR/:NO/.WDSF 0)
(error (/" |Failure to run STR/:GC-DAEMON|)))
(str/:grow-array wds-required)
(nointerrupt 'T))
(defun STR/:GC-DAEMON (() )
;; *RSET is () when MAKE-STRING calls the GC
(declare (fixnum i nn max))
(unless (eq STR/:NULL-STRING (STR/:GCMARRAY 0))
(error (/" |STRING bug detected by STR/:GC-DAEMON|)
'(STR/:GCMARRAY 0)))
(do ((i 1 (1+ i)) ;index which cycles thru gcmarray
(lui 0) ;last used index - for compacting gcmarray
(nn 0)
(str) )
((= i STR/:NO/.STRS)
(setq lui (1+ lui)) ;actual # of strings used
(unless (= lui i)
(setq nn (+ nn (- STR/:ARYSIZE (wordno-of-next-freeslot lui)))))
(setq STR/:NO/.STRS lui STR/:NO/.WDSF nn)
(when ↑D (terpri msgfiles) ;print stats if desired
(princ '|;STRING space: | msgfiles)
(prin1 STR/:NO/.STRS msgfiles)
(tyo #// msgfiles)
(prin1 STR/:GCMSIZE msgfiles)
(princ '| strings, (| msgfiles)
(prin1 (- STR/:ARYSIZE STR/:FREESLOT) msgfiles)
(tyo #/+ msgfiles)
(prin1 STR/:NO/.WDSF msgfiles)
(princ '|)//| msgfiles)
(prin1 STR/:ARYSIZE msgfiles)
(princ '| words.| msgfiles)))
(cond ((null (setq str (STR/:GCMARRAY i))) () ) ;Already flushed this one?
((not (eq (typep str) 'HUNK4))
(error (/" |STRING bug detected by STR/:GC-DAEMON|)
`(STRING ,str)))
((car str) ;If still valid, then count
(setq lui (1+ lui)) ; up any space reclaimed
(unless (= lui i)
(setq nn (+ nn (- (word-no str)
(wordno-of-next-freeslot lui))))
(store (STR/:GCMARRAY lui) ;Compress GCMARRAY, if there
(STR/:GCMARRAY i)) ; are dead strings between
(store (STR/:GCMARRAY i) () ))) ; last used and current.
;; If string is dead, then nullify gcmarray slot, for it is garbage!
('T (store (STR/:GCMARRAY i) () )))))
) ;end of moby #+PDP10
;;;; *:FIXNUM-TO-CHARACTER, DIGITP, DIGITP-N
;;;; STRING-SUBSEQ, STRING-MISMATCHQ
#-FOR-NIL (progn 'compile
(defun STR/:CHARACTER-VALUEP (x) (and (fixnump x) (<= 0 x #O7777)))
(defun *:FIXNUM-TO-CHARACTER (x &aux (n 0))
(declare (fixnum n))
(and *RSET (check-type x #'STR/:CHARACTER-VALUEP '*:FIXNUM-TO-CHARACTER))
(cond ((cond ((< (setq n x) #.(↑ 2 *:bits-per-character)))
('T (and (bit-test n #O4000) ;IOR the %TXTOP bit to
(setq n (bit-set #O1000 n))) ; %TXSFT position, and
(setq n (logand #O1777 n)) ; fold down to 10. bits
(< (setq n x) #.(↑ 2 *:bits-per-character))))
(ar-1 |+internal-CHARACTER-table/|| n))
('T (setq x (munkam n))
(cdr (cond ((assq x (ar-1 |+internal-CHARACTER-table/||
#.(↑ 2 *:bits-per-character))))
('T (setq x (cons x (new-character n)))
(push x (ar-1 |+internal-CHARACTER-table/||
#.(↑ 2 *:bits-per-character)))
x))))))
(defun STRING-SUBSEQ (str i &optional (cnt 0 cntp))
(cond (*RSET (check-subsequence (str i cnt) 'STRING 'STRING-SUBSEQ #T cntp))
((not cntp) (setq cnt (- (string-length str) i))))
#-Multics (string-replace (make-string cnt) str 0 i cnt)
#+Multics (substr str i cnt)
)
;;; Someday, STRING-MISMATCHQ should be rewritten in MIDAS.
(defun STRING-MISMATCHQ (s1 s2 &optional i1 i2 (cnt 200000. cntp))
(declare (fixnum ls1 ls2 i n))
(if (null i1) (setq i1 0))
(if (null i2) (setq i2 0))
(when *RSET
(let ((foo1 cnt) (foo2 cnt))
(check-subsequence (s1 i1 foo1) 'STRING 'STRING-MISMATCHQ #T cntp)
(check-subsequence (s1 i2 foo2) 'STRING 'STRING-MISMATCHQ #T cntp)
(setq cnt (if (< foo1 foo2) foo1 foo2)
cntp #T)))
(let ((ls1 (- (string-length s1) i1))
(ls2 (- (string-length s2) i2)))
(if (not cntp) (setq cnt (if (< ls1 ls2) ls1 ls2)))
(dotimes (i cnt)
(unless (= (+internal-char-n s1 (+ i1 i))
(+internal-char-n s2 (+ i2 i)))
(return (+ i1 i))))))
) ;end of #-FOR-NIL
;;;; STRING-PNGET and STRING-PNPUT
#+PDP10 (progn 'COMPILE
(defun STRING-PNGET (string seven)
(when *RSET
(unless (and (fixnump seven) (= seven 7))
(error (/" |Uluz - need 7|) seven))
(check-type string #'STRINGP 'STRING-PNGET))
(let* ((str-ln (string-length string))
(no/.wds-1 (1- (no-words-used str-ln)))
(odd-wordp (\ str-ln #.*:bytes-per-word))
(lastword (+internal-string-word-n string no/.wds-1))
(wdsl `(,(if (= odd-wordp 0)
lastword
;; Maybe have to truncate unwanted chars off last word
(deposit-byte lastword
0
(1+ (* (- #.*:bytes-per-word odd-wordp)
#.*:bits-per-character))
0)))))
(declare (fixnum str-ln no/.wds-1 odd-wordp lastword))
(dotimes (i no/.wds-1)
(push (+internal-string-word-n string (- no/.wds-1 i 1)) wdsl))
wdsl))
(defun STRING-PNPUT (l () )
(when *RSET
(and l (check-type l #'PAIRP 'STRING-PNPUT)))
(let* ((no/.wds (length l))
(str-ln (* no/.wds #.*:bytes-per-word))
(str (make-string str-ln)))
(declare (fixnum no/.wds))
(dolist (word l i) (+internal-set-string-word-n str i word))
(let* ((*RSET)
(where (string-bskipq-n 0 str str-ln 5)))
(unless (null where) (set-string-length str (1+ where))))
str))
;;; Still within an #+FM
;;; Still within an #+FM
;;;; STRING-HASH and |*lexpr-funcall-1|
(defun STRING-HASH (str &optional start-i (cnt 0 cntp))
(if (null start-i) (setq start-i 0))
(when *RSET
(check-subsequence (str start-i cnt) 'STRING 'STRING-HASH #T cntp)
(setq cntp #T))
(let ((str-ln (string-length str)))
(declare (fixnum str-ln))
(if (not cntp) (setq cnt (- str-ln start-i)))
(cond
((= cnt 0) 12345.)
('T (unless (= (\ start-i #.*:bytes-per-word) 0)
(setq str (string-subseq str start-i cnt) start-i 0))
(let* ((1stword-i (// start-i #.*:bytes-per-word))
(no/.wds-1 (1- (no-words-used cnt)))
(odd-wordp (\ cnt #.*:bytes-per-word))
(hash (+internal-string-word-n str (+ 1stword-i no/.wds-1))))
(declare (fixnum 1stword-i no/.wds-1 odd-wordp hash))
(if (not (= odd-wordp 0))
;; Maybe have to truncate unwanted chars off last word
(setq hash (deposit-byte
hash
0
(1+ (* (- #.*:bytes-per-word odd-wordp)
#.*:bits-per-character))
0)))
(do ((i (- no/.wds-1 1stword-i 1) (1- i)))
((< i 1stword-i))
(declare (fixnum i))
(setq hash (logxor (+internal-string-word-n str i) hash)))
(lsh hash -1))))))
(defun |*lexpr-funcall-1| (name fun first-arg args-prop)
;; Function for passing the buck
(let ((n (arg () )))
(and (or (< n (car args-prop)) (> n (cdr args-prop)))
(error (/" |Wrong number args to function|) name))
(caseq n
(1 (lexpr-fcl-helper 1))
(2 (lexpr-fcl-helper 2))
(3 (lexpr-fcl-helper 3))
(4 (lexpr-fcl-helper 4))
(5 (lexpr-fcl-helper 5))
(6 (lexpr-fcl-helper 6)))))
) ;end of #+FM
;;;; DIGITP, DIGIT-WEIGHT, and |STR/:STRING-SEARCHer|
(defun DIGITP (c)
(and (setq c (to-character-n? c #T))
(<= #/0 c #/9)))
(defun DIGIT-WEIGHT (c)
(setq c (to-character-n? c () ))
(cond ((<= #/0 c #/9) (- c #/0))
((<= #/A c #/Z) (- c #.(- #/A 10.)))
((<= #/a c #/z) (- c #.(- #/a 10.)))))
(defun |STR/:STRING-SEARCHer|
((op . fwp) s1 s2 &optional (i2 () i2p) (cnt 0 cntp))
(if (null i2) (setq i2 0 i2p () ))
(when *RSET
(check-type s1 #'STRINGP 'STRING-SEARCH)
(check-subsequence (s2 i2 cnt) 'STRING 'STRING-SEARCH i2p cntp fwp)
(setq cntp #T))
(let* ((ls1 (string-length s1))
(ls2 (string-length s2))
(mpsi (- ls2 ls1)) ;maximum possible start index
(ss-i (if (or fwp i2p) i2 (1+ mpsi))) ;search start index
)
(declare (fixnum ls1 ls2 mpsi ss-i))
(cond
((< mpsi 0) () )
((= ls1 0)
;; Backwards search -- convert from "limit" index to top-value index
(if (not fwp) (setq ss-i (1- ss-i)))
ss-i)
((let* ((haumany (if fwp (1+ (- mpsi ss-i)) ss-i))
(mnpsi (- mpsi haumany -1)) ;Minimum possible start index
(1st-p-c (+internal-char-n s1 0))) ;First pattern char
(declare (fixnum haumany 1st-p-c mnpsi))
(if (and cntp (< cnt haumany)) (setq haumany cnt))
(do ((j)
(nxt-i ss-i (cond ((null j) () )
(fwp (1+ j))
('T j)))
(*RSET))
((cond ((null nxt-i)) ;Iterate while "next" search-
(fwp (> nxt-i mpsi)) ; start index is within bounds
('T (<= nxt-i mnpsi)))
() )
(caseq op
(SEARCH
(setq j
(cond (fwp (string-search-char 1st-p-c s2 nxt-i))
('T (string-reverse-search-char 1st-p-c s2 nxt-i))))
(and j
(<= mnpsi j mpsi)
(string-equal s1 s2 0 j ls1 (+ j ls1))
(return j)))
#-FOR-NIL
(SEARCHQ
(setq j
(cond (fwp (string-posq-n 1st-p-c s2 nxt-i haumany))
('T (string-bposq-n 1st-p-c s2 nxt-i haumany))))
(and j
(<= mnpsi j mpsi)
(not (string-mismatchq s1 s2 0 j ls1))
(return j))
(if j (setq haumany (- haumany (if fwp (1+ (- j nxt-i))
(- nxt-i j))))))
(T (error (/" |Lost OP in STR/:STRING-SEARCHer|))))))))))
;;;; SUBSTRING, STRING-APPEND, STRING-REVERSE, STRING-NREVERSE,
;; LISPM compatibility stuff
#-LISPM
(progn 'compile
(defun SUBSTRING (str &optional (i () ip) (lmi 1 lmip))
(if (null ip) (setq i 0 ip () ))
(when *RSET
;; Check as if "end-index" were a start for backwards searching
(check-subsequence (str lmi () ) 'STRING 'SUBSTRING lmip)
(if ip (check-type i #'SI:NON-NEG-FIXNUMP 'SUBSTRING)))
(string-subseq str i (- (if lmip lmi (string-length str)) i)))
#-Multics
(defun STRING-APPEND #-FOR-NIL n #+FOR-NIL (&rest w &aux (n (vector-length w)))
(let ((new-len 0) str)
(declare (fixnum new-len))
(dotimes (i n) ;Calculate total length
(setq str (s-arg w i)) ; of resultant string
(if *RSET (check-type str #'STRINGP 'STRING-APPEND))
(setq new-len (+ new-len (string-length str))))
(let ((newstr (make-string new-len))
(ii 0) ;"ii" is a running start index
*RSET)
(dotimes (i n)
(setq str (s-arg w i))
(unless (= (string-length str) 0) ;Fill in parts of new string
(string-replace newstr str ii)
(setq ii (+ ii (string-length str)))))
newstr)))
(defun STRING-REVERSE (str &optional start (cnt 0 cntp))
(str/:string-reverser str #T start cnt cntp))
(defun STRING-NREVERSE (str &optional start (cnt 0 cntp))
(str/:string-reverser str () start cnt cntp))
;;;; STR/:STRING-REVERSER STR/:STRING-EQUAL-LESSP
;;; Remember, still within a #-LISPM conditional
(defun STR/:STRING-REVERSER (str newp start cnt cntp &aux (newstr str))
(if (null start) (setq start 0))
(cond (*RSET
(check-subsequence (str start cnt)
'STRING
(if newp 'STRING-REVERSE 'STRING-NREVERSE)
#T
cntp)
(if newp (let (*RSET) (setq newstr (string-subseq str start cnt)))))
((let ((lstr (string-length str)))
(declare (fixnum lstr))
(cond ((not cntp) (setq cnt (- lstr start)))
((not (<= (+ start cnt) lstr))
(setq cnt (- lstr start))))
(if newp (setq newstr (string-subseq str start cnt))))))
(if newp (setq start 0))
(do ((i start (1+ i))
(ii (+ start cnt -1) (1- ii))
chii)
((> i ii) )
(declare (fixnum i ii chii))
(setq chii (+internal-char-n newstr ii)) ;Save an interchange char,
(+internal-rplachar-n newstr ii (+internal-char-n newstr i))
(+internal-rplachar-n newstr i chii)) ; and pairwise-interchange
newstr)
(defun STR/:STRING-EQUAL-LESSP
(foo s1 s2 &optional (i1 () i1p) (i2 () i2p) (lm1 0 lm1p) (lm2 0 lm2p))
(declare (fixnum i1* i2* ls1 ls2))
(if (null i1) (setq i1 0 i1p () ))
(if (null i2) (setq i2 0 i2p () ))
(let (((nocasep . equalp) foo)
(ls1 0) (ls2 0) (cnt1 0) (cnt2 0))
(cond
(*RSET
;; Check as if "end-index" were a start for backwards searching
(check-subsequence (s1 lm1 () ) 'STRING 'STR/:STRING-EQUAL-LESSP
lm1p () () )
(check-subsequence (s2 lm2 () ) 'STRING 'STR/:STRING-EQUAL-LESSP
lm2p () () )
(if i1p (check-type i1 #'SI:NON-NEG-FIXNUMP 'STR/:STRING-EQUAL-LESSP))
(if i2p (check-type i2 #'SI:NON-NEG-FIXNUMP 'STR/:STRING-EQUAL-LESSP))
(setq cnt1 (- lm1 i1) cnt2 (- lm2 i2))
(check-subsequence (s1 i1 cnt1) 'STRING 'STR/:STRING-EQUAL-LESSP)
(check-subsequence (s2 i2 cnt2) 'STRING 'STR/:STRING-EQUAL-LESSP)
(setq ls1 (string-length s1) ls2 (string-length s2)))
('T (setq ls1 (string-length s1) ls2 (string-length s2))
(setq cnt1 (- (if lm1p lm1 ls1) i1)
cnt2 (- (if lm2p lm2 ls2) i2))))
(cond
((and equalp (not (= cnt1 cnt2))) () )
((and (not equalp) (= cnt1 0)) (not (= cnt2 0)))
((do ((i1* i1 (1+ i1*)) ;Iterate over the two
(i2* i2 (1+ i2*)) ; strings, looking for
(i (if (< cnt1 cnt2) cnt1 cnt2) (1- i)) ; a place of discord
(c1 0) (c2 0))
((<= i 0)
(if (or equalp (> (- lm2 i2*) (- lm1 i1*)))
#T))
(declare (fixnum i c1 c2))
(setq c1 (+internal-char-n s1 i1*)
c2 (+internal-char-n s2 i2*))
(unless (if nocasep (= c1 c2) (char-equal c1 c2))
;;No decision possible when chars are "equal"
(return (cond (equalp () )
(nocasep (< c1 c2))
('T (char-lessp c1 c2)))))) )) ))
;;; Remember, still within a #-LISPM conditional
(comment GET-PNAME STR/:STRING-UP-DOWN-CASE TRIMers)
;LISPM compatibility stuff
#+PDP10
(defun GET-PNAME (x) (string-pnput (pnget x 7) 7))
(defun STR/:STRING-UP-DOWN-CASE (up s1 &optional i1 (cnt 0 cntp))
(if (null i1) (setq i1 0))
(cond (*RSET
(check-subsequence (s1 i1 cnt)
'STRING
(if up 'STRING-UPCASE 'STRING-DOWNCASE)
#T
cntp)
(setq cntp #T)))
(let ((ls1 (string-length s1))
(ch 0)
newstr)
(declare (fixnum ls1 ch))
(unless cntp (setq cnt (- ls1 i1)))
(setq newstr (make-string cnt))
(dotimes (i cnt)
(setq ch (+internal-char-n s1 (+ i i1)) ;get this char
ch (if up (char-upcase ch) (char-downcase ch))) ;case-ify it
(+internal-rplachar-n newstr i ch))
newstr))
(defun STRING-LEFT-TRIM (cl str)
(let ((i1* (string-search-not-set cl str)))
(cond ((null i1*) STR/:NULL-STRING)
((string-subseq str i1*)))))
(defun STRING-RIGHT-TRIM (cl str)
(let ((i1* (string-reverse-search-not-set cl str)))
(cond ((null i1*) STR/:NULL-STRING)
((string-subseq str 0 (1+ i1*))))))
(defun STRING-TRIM (cl str)
(let ((i1* (string-search-not-set cl str)) i2*)
(cond ((null i1*) STR/:NULL-STRING)
((null (setq i2* (string-reverse-search-not-set cl str)))
STR/:NULL-STRING)
((string-subseq str i1* (- i2* i1* -1))))))
) ;end of moby #-LISPM conditional
;;;; Fill-in primitives
#+Multics
(defun MAKE-STRING (n)
(do ((s "" (catenate s ""))
(i n (- n 4)))
((< i 4)
(cond ((= i 0) s)
((catenate (cond ((= i 1) "")
((= i 2) "")
((= i 3) ""))
s))))))
#Q
(defun MAKE-STRING (n)
(let ((s (make-array () 'ART-16B n)))
(as-1 s STRING-CLASS 0)
s))
#-PDP10 (progn 'compile
(defun |STR/:STRING-POSQer| (foo char str &OPTIONAL (i* 0) (cnt 0 cntp))
(setq char (*:character-to-fixnum char))
(cond (cntp (|STR/:STRING-POSQ-Ner| foo char str i* cnt))
('T (|STR/:STRING-POSQ-Ner| foo char str i*))))
(defun |STR/:STRING-POSQ-Ner| (foo char str &OPTIONAL (i* () i*p) (cnt 0 cntp)
&AUX (op (car foo))
(fwp (cdr foo)) )
(if (null i*) (setq i* 0 i*p () ))
(if (eq op 'FILL) (exch char str))
(if *RSET
(check-type char #'STR/:CHARACTER-VALUEP op)
(check-subsequence (str i* cnt) 'STRING op i*p cntp fwp))
(do ((n (cond (cntp cnt)
(fwp (- (string-length str) i*))
((1+ i*)))
(1- n))
(i i* (cond (fwp (1+ i)) ((1- i)))))
((= n 0) () )
(declare (fixnum n i))
(if (eq op 'FILL) (+internal-rplachar-n str i char)
(if (eq op (if (= char (+internal-char-n str i)) 'POSQ 'SKIPQ))
(return i)))))
) ;end of #-PDP10
;;;; PDP10 hooks - Methods for PRINT, EXPLODE, SXHASH, NAMESTRING
#+PDP10 (progn 'compile
(defmethod* (PRINT STRING-CLASS) (str ofile () slashifyp)
(if *RSET (check-type str #'STRINGP 'PRINT->STRING-CLASS))
(if slashifyp (tyo #/" ofile))
(do ((len (string-length str))
(i 0 (1+ i))
(c 0))
((>= i len) )
(declare (fixnum len i c))
(setq c (+internal-char-n str i))
(and slashifyp (or (= c #/") (= c #//)) (tyo #// ofile))
(tyo c ofile))
(and slashifyp (tyo #/" ofile)))
(defmethod* (PRINT CHARACTER-CLASS) (obj files () slashifyp)
(cond (slashifyp (princ '|}//| files)))
(tyo (*:character-to-fixnum obj) files))
(defmethod* (EXPLODE STRING-CLASS) (str slashifyp number-p)
(check-type str #'STRINGP 'PRINT->STRING-CLASS)
(do ((strlist (and slashifyp
(if number-p (ncons #/") (ncons '/")))
(cons c strlist))
(len (string-length str))
(i 0 (1+ i))
(c 0))
((>= i len)
(if slashifyp (push (if number-p #/" '/") strlist))
(nreverse strlist))
(declare (fixnum len i))
(setq c (+internal-char-n str i))
(if (not number-p) (setq c (ascii c)))
(and slashifyp
(or (= c #/") (= c #//))
(push (if number-p #// '//) strlist))))
(defmethod* (EXPLODE CHARACTER-CLASS) (object slashify-p number-p)
(let ((result (cons #/}
(if slashify-p
(cons #//
(ncons (*:character-to-fixnum object)))
(ncons (*:character-to-fixnum object))))))
(if (not number-p) (mapcar 'ascii result) result)))
(defmethod* (SXHASH STRING-CLASS) (string) (string-hash string))
(defmethod* (NAMESTRING STRING-CLASS) (string)
(pnput (string-pnget string 7) () ))
(defmethod* (SAMEPNAMEP STRING-CLASS) (string other-obj)
(str/:string-equal-lessp '(T . T)
string
(cond ((stringp other-obj) other-obj)
('T (to-string other-obj)))))
(defmethod* (ALPHALESSP STRING-CLASS) (string other-obj)
(str/:string-equal-lessp '(T . () )
string
(cond ((stringp other-obj) other-obj)
('T (to-string other-obj)))))
;;;; PDP10 hooks - methods for EQUAL, FLATSIZE, PURCOPY, USERATOMS
(DEFMETHOD* (EQUAL STRING-CLASS) (OBJ OTHER-OBJ)
(AND (STRINGP OTHER-OBJ)
(= (STRING-LENGTH OBJ) (STRING-LENGTH OTHER-OBJ))
(NULL (STRING-MISMATCHQ OBJ OTHER-OBJ))))
(DEFMETHOD* (FLATSIZE STRING-CLASS) (OBJ () () SLASHIFYP)
(DECLARE (FIXNUM MAX CNT))
(COND (SLASHIFYP
(DO ((MAX (1- (STRING-LENGTH OBJ)))
(I -1 (STRING-SEARCH-SET '(#/" #//) OBJ (1+ I)))
(CNT 2 (1+ CNT)))
((OR (NULL I) (= I MAX))
(+ CNT (COND (I (1+ MAX)) (MAX)))) ;Fix fencepost
))
('T (STRING-LENGTH OBJ))))
(defmethod* (FLATSIZE CHARACTER-CLASS) (() () () slashifyp)
(if slashifyp 3 1))
(DEFMETHOD* (PURCOPY STRING-CLASS) (x)
(let ((nx (purcopy STR/:STRING-HUNK-PATTERN))
(nwds 1)
(str-len 0))
(declare (fixnum nwds str-len))
(and (cond ((not (stringp x)))
((< (setq str-len (string-length x)) 0))
((> (setq nwds (no-words-used str-len)) 512.)))
(error (/" |Can't PURCOPY a string this long|) x))
(let ((oni (nointerrupt 'T)))
(if (< STR/:NO/.PWDSF nwds)
(setq STR/:PURE-ADDR (STR/:GRAB-PURSEG)
STR/:NO/.PWDSF 512.))
(set-word-no nx (purcopy (logior 1←35. (- (+ STR/:PURE-ADDR 512.)
STR/:NO/.PWDSF))))
(setq STR/:NO/.PWDSF (- STR/:NO/.PWDSF nwds))
(nointerrupt oni))
(setf (*:extend-class-of nx) (*:extend-class-of x))
(setf (*:extend-marker-of nx) (*:extend-marker-of x))
(set-string-length nx (purcopy str-len))
(if (> str-len 0) (string-replace nx x 0 0 str-len))
nx))
(defmethod* (USERATOMS-HOOK STRING-CLASS) (x)
(list `(STRING-PNPUT ',(string-pnget x 7) #T)))
(defmethod* (USERATOMS-HOOK CHARACTER-CLASS) (x)
;; Don't macroexpand this - need the use of autoload properties
(list `(*:FIXNUM-TO-CHARACTER ,(*:character-to-fixnum x))))
) ;end of #+PDP10
;;;; Set up tables and constants
#+FM
(mapc '(lambda (x) (set x (get x 'lsubr)))
'(|STR/:STRING-SEARCHer| STR/:STRING-EQUAL-LESSP STR/:STRING-UP-DOWN-CASE
#-PDP10 |STR/:STRING-POSQ-Ner| #-PDP10 |STR/:STRING-POSQer| ))
#Q (mapc '(lambda (x) (set x (fsymeval x)))
'(|STR/:STRING-POSQ-Ner| |STR/:STRING-POSQer|))
#+PDP10 (SETQ *FORMAT-STRING-GENERATOR 'TO-STRING)
#-FOR-NIL (progn 'compile
(setq |+internal-CHARACTER-table/||
(*array () 'T #.(1+ (↑ 2 *:bits-per-character))))
;;Fill in this table with the full 128. character objects,
;; for the ASCII alphabet, leaving a 129.th slot for a list
;; of folded-down 12-bit characters seen.
(do ((i #.(1- (↑ 2 *:bits-per-character)) (1- i))
(*RSET))
((< i 0))
(store (arraycall T |+internal-CHARACTER-table/|| i) (new-character i 'T)))
(defun |+internal-tilde-macro/|| #-LISPM () #Q (ignore ignore)
(let ((c (tyi)))
(declare (fixnum c))
(and (= c #//) (setq c (tyi))) ;Check for slash
(*:fixnum-to-character c)))
#-LISPM (setsyntax '/} 'MACRO '|+internal-tilde-macro/||)
#Q (set-syntax-macro-char #/} '|+internal-tilde-macro/||)
#+PDP10 (progn 'compile
(defun |+internal-doublequote-macro/|| ()
(declare (fixnum ln i c))
(do ((c (tyi) (tyi))
(charsl))
((= c #/")
(let* ((ln (length charsl))
(str (make-string ln)))
(declare (fixnum ln))
(dotimes (i ln) (+internal-rplachar-n str (- ln i 1) (pop charsl)))
str))
(push (if (= c #//) (tyi) c) charsl)))
(setsyntax '/" 'MACRO '|+internal-doublequote-macro/||)
) ;end of #+PDP10
) ;end of #-FOR-NIL
(mapc '(lambda (x) (putprop x #T '|side-effectsp/||))
'(CHAR CHAR-N +INTERNAL-CHAR-N CHARACTERP
*:CHARACTER-TO-FIXNUM *:FIXNUM-TO-CHARACTER
TO-CHARACTER TO-CHARACTER-N TO-CHARACTER-N?
TO-STRING DIGITP DIGIT-WEIGHT
CHARACTER CHAR-EQUAL CHAR-LESSP GET-PNAME
MAKE-STRING STRING-SEARCHQ STRING-BSEARCHQ STRING-MISMATCHQ
STRING-POSQ STRING-BPOSQ STRING-POSQ-N STRING-BPOSQ-N
STRING-SKIPQ STRING-BSKIPQ STRING-SKIPQ-N STRING-BSKIPQ-N
STRING-EQUAL STRING-LESSP STRING-SEARCH STRING-REVERSE-SEARCH
STRING-DOWNCASE STRING-UPCASE CHAR-DOWNCASE CHAR-UPCASE
STRING-REVERSE SUBSTRING STRING-APPEND STRING-SUBSEQ
STRING-SEARCH-CHAR STRING-SEARCH-NOT-CHAR
STRING-SEARCH-SET STRING-SEARCH-NOT-SET
STRING-REVERSE-SEARCH-CHAR STRING-REVERSE-SEARCH-NOT-CHAR
STRING-REVERSE-SEARCH-SET STRING-REVERSE-SEARCH-NOT-SET
STRING-PNGET STRING-PNPUT STRING-HASH
) )
#+PDP10
(setq GC-DAEMON
(cond ((null GC-DAEMON) 'STR/:GC-DAEMON)
((let ((g (gensym))
(h (cond ((or (symbolp gc-daemon)
(and (not (atom gc-daemon))
(eq (car gc-daemon) 'LAMBDA)))
`(,gc-daemon))
(`(FUNCALL ',gc-daemon)))))
`(LAMBDA (,g)
(STR/:GC-DAEMON ,g)
(,.H ,g))))))
(sstatus feature STRING)
ββββ